﻿#light
namespace AssemblyMonkey
open System
open System.IO

open Mono.Cecil
open Mono.Cecil.Cil
open Cecil.Decompiler
open Cecil.Decompiler.Languages

module CodeUrl =
    let endcode (def: obj) =
        let write (ass:AssemblyDefinition) typeName memberName =
            let memberThing =
                match memberName with
                | Some x -> Printf.sprintf ".%s" x
                | _ -> ""
            let n = ass.Name
            let v = n.Version
            let token = match n.PublicKeyToken with | null -> "" | x -> x |> Seq.fold (fun acc x -> acc + x.ToString()) ":" 
            Printf.sprintf "%s:%i.%i.%i.%i%s/%s%s" 
                n.Name v.Major v.Minor v.Revision v.Build token typeName memberThing
        match def with
        | :? TypeDefinition as typ -> write typ.Module.Assembly typ.FullName None // needed ??
        | :? TypeReference as typ -> write typ.Module.Assembly typ.FullName None
        | :? PropertyDefinition as prop -> 
            let typ = prop.DeclaringType
            write typ.Module.Assembly typ.FullName (Some prop.Name)
        | :? MethodDefinition as meth -> 
            let typ = meth.DeclaringType
            write typ.Module.Assembly typ.FullName (Some meth.Name) // TODO overloads
        | :? FieldDefinition as field -> 
            let typ = field.DeclaringType
            write typ.Module.Assembly typ.FullName (Some field.Name)
        | :? EventDefinition as event -> 
            let typ = event.DeclaringType
            write typ.Module.Assembly typ.FullName (Some event.Name)
        | :? VariableDefinition as event -> "TODO: VariableDefinition"
        | _ -> Printf.sprintf "TODO: %s %A" (def.GetType().FullName) def //failwith (Printf.sprintf "object type can not be encoded: %A" def)
        
    let decode url = () :> obj

type HtmlFormatter(writer: TextWriter) = 
    let header = "<html>
<head>
<style type=\"text/css\">
p {font-family: consolas, courier; font-size: 9pt; overflow:hidden; white-space:nowrap;}
.comment {color: green}
.keyword {color: blue}
.literal {color: brown}
.reference {font-style: bold}
A:link { text-decoration: none}
A:active { text-decoration: none}
A:visited { text-decoration: none}
</style>
</head>
<body><p>"
    do writer.WriteLine(header)
    let mutable indent = 0 
    let mutable writeIndent = true
    let write (s:string) =
        if writeIndent then
            writer.Write(String.concat "" (List.init indent (fun _ -> "&nbsp;")))
            writeIndent <- false
        writer.WriteLine(s)
    interface IFormatter with
        member x.Write (str: string) = write str
        member x.WriteLine () = 
            write "<br />"
            writeIndent <- true
        member x.WriteSpace () = write "&nbsp;"
        member x.WriteToken (token: string) = write token
        member x.WriteComment (comment: string) = 
            write (Printf.sprintf "<span class =\"comment\">%s</span>" comment)
        member x.WriteKeyword (keyword: string) = 
            write (Printf.sprintf "<span class =\"keyword\">%s</span>" keyword)
        member x.WriteLiteral (literal: string) = 
            write (Printf.sprintf "<span class =\"literal\">%s</span>" literal)
        member x.WriteDefinition ((value: string), (definition: obj)) = 
            write (Printf.sprintf "<span class =\"reference\"><a href=\"%s\">%s</a></span>" (CodeUrl.endcode definition) value)
        member x.WriteReference ((value: string), (reference: obj)) = 
            write (Printf.sprintf "<span class =\"reference\"><a href=\"%s\">%s</a></span>" (CodeUrl.endcode reference) value)
        member x.Indent () = indent <- indent + 4
        member x.Outdent () = indent <- indent - 4
    interface IDisposable with
        member x.Dispose () =
            writer.WriteLine("</p></body></html>")
    member x.WriteFooter() = 
        let disp = x :> IDisposable
        disp.Dispose()

